#
# Heuristics for determining the bounceness of a message
#
package Mail::Bounce::Heuristic;

use strict;
use MIME::WordDecoder;

use vars qw(@ISA %knownmailer %knownsubjects $DEBUG);

$DEBUG = 0;

@ISA = qw(Mail::Bounce);
#----------------------------------------------
# Knowledge tables for ad-hoc parsing
#----------------------------------------------

%knownmailer = map {$_ => 1}
(
"postmaster",
"Postmaster",
"PostMaster",
"POSTMASTER",
"MAILER-DAEMON",
"Mailer-Daemon",
"mailer-daemon",
"root",
"mail",
"postman+",
"FETCHMAIL-DAEMON",
 );

%knownsubjects = 
(
 "Mail System Error - Returned Mail"              => "Mail::Bounce::Netscape",
 "Undelivered Mail Returned to Sender"            => "Mail::Bounce::Postfix",
 "failure notice"                                 => "Mail::Bounce::Qmail",
 "Mail delivery failed: returning message to sender" => "Mail::Bounce::Exim",
 "Returned mail: User unknown"                   => "Mail::Bounce::Sendmail5",
 "Returned mail - nameserver error report"       => "Mail::Bounce::PHQuery",
 "Delivery Report (failure) for @"               => "Mail::Bounce::MixerPP",
 "Delivery failure notification"                 => "Mail::Bounce::Mercury",
 "Returned Mail"                                 => "Mail::Bounce::Bigfoot",
 "<no subject>"                                  => "Mail::Bounce::Fetchmail",
 "Mail status report"                            => "Mail::Bounce::DSMTP",
#"Mail Delivery failed: returning to sender", "permfail",
#"mail failed, returning to sender", "lookatbody smail",
#"Unknown recipient", "permfail",
#"Returned mail: Host unknown (*)", "permfail",
#"Returned Mail", "permfail", # obscure mailer
		 );

# special trickery for charsets handling
my $wd = default MIME::WordDecoder;
$wd->handler('SEN_850200_B' => "KEEP");


sub classify {

    my $self = shift;
    my $from = $self->head->get("from");
    my $subject = unmime($self->head->get("subject"));
    $subject = "<no subject>" if !$subject;
    my $result;
    my $fromuser;
    $subject =~ tr/\r\n//d;
    $DEBUG && print "Subject: $subject\n";
    $DEBUG && print "From: $from\n";
    if ($from =~ /([+.0-9A-Za-z-]+)@/) {
	$fromuser = $1;
    } else {
	warn "From field contained strange characters: $from\n";
	$fromuser = "<strange>";
    }
    my $oldclass = ref $self;
    bless $self, "Mail::Bounce::Heuristic";
    if (defined($knownmailer{$fromuser})) {
	# We think this came from a mailer daemon
	# Try to take out trailing email address
	$subject =~ s/\S+\@\S+$/\@/ if !$knownsubjects{$subject};
	# Try to take out trailing comment
	$subject =~ s/\(.*\)$/(*)/ if !$knownsubjects{$subject};
	if ($knownsubjects{$subject}) {
	    my $action = $knownsubjects{$subject};
	    if ($action =~ /^Mail::Bounce/) {
		eval "use $action";
		die "Unable to use $action: $@" if $@;
		$self->turninto($action);
	    } else {
		# do nothing
	    }
	} elsif ($subject eq "Undeliverable Message"
		 && $self->head->get("From") =~ /^CompuServe Postmaster/) {
	    $self->turninto("Mail::Bounce::Compuserve");
	} elsif ($subject =~ /^Undeliverable:/
		 && $self->head->get("X-Mailer") =~ /Internet Mail Service/) {
	    $self->turninto("Mail::Bounce::Exchange");
	} else {
	    # failed to identify as heuristic bounce
	    $DEBUG && warn "Unknown subject - return to $oldclass\n";
	    $self->turninto($oldclass);
	}
    } else {
	# failed to identify as heuristic bounce
	$DEBUG && warn "Sender $fromuser is not a known mailer\n";
	$self->turninto($oldclass);
    }
    return (ref $self ne $oldclass);
}

sub turninto {
    my $self = shift;
    my $newclass = shift;
    my $was = ref $self;

    eval "use $newclass";
    $DEBUG && warn "Trying $newclass\n";
    bless $self, $newclass;
    if (!$self->validate()) {
	bless $self, $was;
	$DEBUG && warn "Validate for $newclass failed\n";
    }
}

sub isbounce {
    return 1;
}

# Checking whether it is really of my class
# Return false for anything that has been subclassed to
# something that does not have a validate() routine
sub validate {
    my $self = shift;
    if (ref $self == "Mail::Bounce::Heuristic") {
	return 1;
    } else {
	die ref $self, " does not have a validate routine\n";
    }
}

sub recipients {
    my $self = shift;
    my $body;


    if ($DEBUG) {
	warn "Subject: ", $self->head->get("subject"), "\n";
	if ($self->is_multipart()) {
	    warn "MIME multipart\n";
	    if (!$self->parts(0)->bodyhandle) {
		warn "Empty first part\n";
		$body = "<no body>\n";
	    } else {
		$body = $self->parts(0)->bodyhandle->as_string;
	    }
	} else {
	    warn "Single-part\n";
	    $body = $self->bodyhandle->as_string;
	}
	$body =~ s/^((.*\n){15})(?s:.*)/$1/;
	warn "Unparsed body (15 first lines):\n--------------\n",
        $body, "---------\n";
    }
    if (wantarray()) {
	die "Recipients not implemented for ", ref $self, "\n";
    } else {
	return 0;
    }
}
    
#-------- Useful routines go below here -----------

sub patternmatch {
    my $self = shift;
    my $body = shift;
    my $pattern;
    my $keywords;
    my $pindex = 0;
    for $pattern (@_) {
	$DEBUG && warn "Pattern $pindex\n";
	++ $pindex;
	$keywords = $self->patternmatch1($body, $pattern);
	return $keywords if defined($keywords);
    }
    return undef;
}

sub patternmatch1 {
    my $self = shift;
    # self is ignored - it is just so we can use method inheritance
    my ($body, $pattern) = @_;
    my @varlist;
    my @results;

    $pattern = quotemeta($pattern);
    # Take out the "variables" pattern
    while ($pattern =~ /\\\$\\{([^}-]*)-([^}]*)\\\}/) {
	my $variable = $1;
	my $varpat = $2;
	# take back out the quotemeta
	$variable =~ s/\\//g;
	$varpat =~ s/\\([^A-Za-z_0-9])/$1/g;
        $DEBUG && warn "variable: $variable pattern $varpat\n";
        push(@varlist, $variable);
	$pattern =~ s/\\\$\\{([^}-]*)-([^}]*)\\\}/($varpat)/;
    }
    # NOTE: there is some trouble with embedded tabs....
    
    if (eval "\@results = \$body =~ /^$pattern/") {
	$DEBUG && warn "Match\n";
        my $res = {};
        my $result;
        while (defined($result = shift @results)) {
            my $name = shift @varlist;
            $DEBUG && warn "$name: $result\n";
	    $$res{$name} = $result if $name;   
        }
        return $res;
    } else {
	$DEBUG && do {
	    warn "No match\n";
	    # debug
	    my $linecount = ($pattern =~ tr/\n/\n/);
	    my ($match, $lastline, $substr, $nonmatch);
	    warn "$linecount lines in pattern\n";
	    loop: while (! (eval "\$body =~ /^$pattern/ && (\$match = \$&)")) {
		$nonmatch = $body;
		$pattern =~ s/\n[^\n]*\n$/\n/ || do {
		    $match = "";
		    last loop;
		};
		$lastline = $&;
		$lastline =~ s/^\n//;
	    }
	    # the value of $& seems not to escape the eval...
	    #$match = $&;
	    $linecount = ($pattern =~ tr/\n/\n/);
	    warn "$linecount lines matched\n";
	    warn "Nonmatch pattern line was $lastline\n";
	    $substr = substr($nonmatch, length($match));
	    $substr =~ s/\n.*//s;
	    warn "Problem part from doc was $substr\n";
	};
	return undef;
    }
}

# Return the first body part as a string, whether it is
# multipart or not.
# Too many mailers use both multipart and non-multipart variants
# with the same strings.
sub firstbodystring {
    my $self = shift;
    
    if ($self->is_multipart) {
	return $self->parts(0)->bodyhandle->as_string;
    } else {
	return $self->bodyhandle->as_string;
    }
}

1;
